home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue28 / opengl / GLTest / ugltest.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1997-10-17  |  9.3 KB  |  273 lines
  1. unit ugltest;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   OpenGL;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     procedure FormCreate(Sender: TObject);
  12.     procedure FormPaint(Sender: TObject);
  13.     procedure FormDestroy(Sender: TObject);
  14.     procedure FormResize(Sender: TObject);
  15.   private
  16.     { Private declarations }
  17.     hRC: hGLRC;                         // permanent Rendering context
  18.     dc: hDC;                            // private GDI Device context
  19.     hPal: hPalette;                     // global palette handle
  20.     procedure WMQueryNewPalette (var Message: TWMQueryNewPalette); message WM_QueryNewPalette;
  21.     procedure WMPaletteChanged (var Message: TWMPaletteChanged); message WM_PaletteChanged;
  22.   public
  23.     { Public declarations }
  24.   end;
  25.  
  26. var
  27.   Form1: TForm1;
  28.  
  29. implementation
  30.  
  31. {$R *.DFM}
  32.  
  33. // Select the pixel format for a given device context
  34.  
  35. procedure SetDCPixelFormat (dc: hDC);
  36. var
  37.     PixelFormat: Integer;
  38.     pfd: TPixelFormatDescriptor;
  39. begin
  40.     FillChar (pfd, sizeof (pfd), 0);
  41.     with pfd do begin
  42.         nSize      := sizeof (pfd);
  43.         nVersion   := 1;
  44.         dwFlags    := PFD_Draw_To_Window or PFD_DoubleBuffer or PFD_Support_OpenGL;
  45.         iPixelType := PFD_Type_RGBA;
  46.         cColorBits := 24;
  47.         cDepthBits := 32;
  48.         iLayerType := PFD_Main_Plane;
  49.     end;
  50.  
  51.     // Choose a pixel format that best matches that described in pfd
  52.     PixelFormat := ChoosePixelFormat (dc, @pfd);
  53.     // Set the pixel format for the device context
  54.     SetPixelFormat (dc, PixelFormat, @pfd);
  55. end;
  56.  
  57. // If necessary, creates a 3-3-2 palette for the device context listed.
  58.  
  59. function GetOpenGLPalette (dc: hDC): hPalette;
  60. var
  61.     pPal: ^TLogPalette;
  62.     pfd: TPixelFormatDescriptor;
  63.     i, Colors, PixelFormat: Integer;
  64.     RedRange,GreenRange,BlueRange: Byte;
  65. begin
  66.     Result := 0;
  67.     // Get the pixel format index and retrieve the pixel format description
  68.     PixelFormat := GetPixelFormat (dc);
  69.     DescribePixelFormat (dc, PixelFormat, sizeof (pfd), pfd);
  70.     // Does this pixel format require a palette?
  71.     // If not, do not create a palette and just return 0
  72.     if (pfd.dwFlags and PFD_Need_Palette) = 0 then Exit;
  73.     // Number of entries in palette.  8 bits yeilds 256 entries
  74.     Colors := 1 shl pfd.cColorBits;
  75.     // Allocate space for a logical palette structure +  palette entries
  76.     GetMem (pPal, sizeof (TLogPalette) + (Colors * sizeof (TPaletteEntry)));
  77.     try
  78.         // Fill in palette header
  79.         pPal^.palVersion := $300;
  80.         pPal^.palNumEntries := Colors;
  81.         // Build mask of all 1's.  This creates a number represented by having
  82.         // the low order x bits set, where x = pfd.cRedBits, pfd.cGreenBits, and
  83.         // pfd.cBlueBits.
  84.         RedRange   := (1 shl pfd.cRedBits)   - 1;
  85.         GreenRange := (1 shl pfd.cGreenBits) - 1;
  86.         BlueRange  := (1 shl pfd.cBlueBits)  - 1;
  87.     // Loop through all the palette entries
  88.     for i := 0 to Colors - 1 do begin
  89.             // Fill in the 8-bit equivalents for each component
  90.         pPal^.palPalEntry[i].peRed   := (i shr pfd.cRedShift) and RedRange;
  91.            pPal^.palPalEntry[i].peRed   := Trunc(pPal^.palPalEntry[i].peRed * 255.0 / RedRange);
  92.             pPal^.palPalEntry[i].peGreen := (i shr pfd.cGreenShift) and GreenRange;
  93.         pPal^.palPalEntry[i].peGreen := Trunc(pPal^.palPalEntry[i].peGreen * 255.0 / GreenRange);
  94.          pPal^.palPalEntry[i].peBlue  := (i shr pfd.cBlueShift) and BlueRange;
  95.           pPal^.palPalEntry[i].peBlue  := Trunc(pPal^.palPalEntry[i].peBlue * 255.0 / BlueRange);
  96.             pPal^.palPalEntry[i].peFlags := 0;
  97.         end;
  98.     // Create the palette
  99.     Result := CreatePalette (pPal^);
  100.     // Select and realize the palette for this device context
  101.     SelectPalette (dc, Result, False);
  102.     RealizePalette (dc);
  103.     finally
  104.     // Free the memory used for the logical palette structure
  105.         FreeMem (pPal, sizeof (TLogPalette) + (Colors * sizeof (TPaletteEntry)));
  106.     end;
  107. end;
  108.  
  109. // Perform any needed initialization on the rendering context.
  110. // Here it sets up and initializes the lighting for the scene.
  111.  
  112. procedure SetupRC (dc: hDC);
  113. const
  114.     // Light values and coordinates
  115.     whiteLight: array [0..3] of GLfloat   = ( 0.4, 0.4, 0.4, 1.0 );
  116.     diffuseLight: array [0..3] of GLfloat = ( 0.8, 0.8, 0.8, 1.0 );
  117.     specular: array [0..3] of GLfloat     = ( 0.9, 0.9, 0.9, 1.0 );
  118.     lightPos: array [0..3] of GLfloat     = ( -100.0, 200.0, 50.0, 1.0 );
  119. var
  120.     font: hFont;
  121.     logFont: TLogFont;
  122.     agmf: array [0..127] of TGlyphMetricsFloat;
  123. begin
  124.     // Setup the Font characteristics
  125.     FillChar (logfont, sizeof (logfont), 0);
  126.     logfont.lfHeight := -10;
  127.     logfont.lfWeight := FW_Bold;
  128.     logfont.lfCharSet := Ansi_CharSet;
  129.     logfont.lfOutPrecision := Out_Default_Precis;
  130.     logfont.lfClipPrecision := Clip_Default_Precis;
  131.     logfont.lfQuality := Default_Quality;
  132.     logfont.lfPitchAndFamily := Default_Pitch;
  133.     lstrcpy (logfont.lfFaceName, 'Times New Roman');
  134.     // Create the font and display list
  135.     Font := CreateFontIndirect (logfont);
  136.     try
  137.         SelectObject (dc, Font);
  138.     // create display lists for glyphs with 0.1 extrusion and default
  139.         // deviation. The display list numbering starts at 1000 (it could
  140.         // be any number)
  141.     wglUseFontOutlines (dc, 0, 128, 1000, 0.0, 1.0, WGL_Font_Polygons, @agmf);
  142.     finally
  143.     DeleteObject (Font);
  144.     end;
  145.     
  146.     glEnable (gl_Depth_Test);    // Hidden surface removal
  147.     glEnable (gl_Color_Material);
  148.     glClearColor (0.0, 0.0, 0.0, 1.0);
  149.     glEnable (gl_Lighting);
  150.     glLightfv (gl_Light0, gl_Ambient, @whiteLight);
  151.     glLightfv (gl_Light0, gl_Diffuse, @diffuseLight);
  152.     glLightfv (gl_Light0, gl_Specular, @specular);
  153.     glLightfv (gl_Light0, gl_Position, @lightPos);
  154.     glEnable (gl_Light0);
  155.  
  156.     glColorMaterial (gl_Front, gl_Ambient_And_Diffuse);
  157.     glMaterialfv (gl_Front, gl_Specular, @specular);
  158.     glMateriali (gl_Front, GL_Shininess, 128);
  159.  
  160.     // Green 3D Text
  161.     glColor3ub (0, 255, 0);
  162.     // Black background
  163.     glClearColor (0.0, 0.0, 0.0, 1.0);
  164. end;
  165.  
  166. procedure TForm1.FormCreate (Sender: TObject);
  167. begin
  168.     // Window creation, setup for OpenGL
  169.     dc := GetDC (Handle);
  170.     SetDCPixelFormat (dc);
  171.     hPal := GetOpenGLPalette (dc);
  172.     // Create the rendering context and make it current
  173.     hRC := wglCreateContext (dc);
  174.     wglMakeCurrent (dc, hRC);
  175.     SetupRC (dc);
  176. end;
  177.  
  178. procedure RenderScene (const TheText: String);
  179. begin
  180.     // Clear the window with current clearing color
  181.     glClear (gl_Color_Buffer_Bit or gl_Depth_Buffer_Bit);
  182.     // Save the matrix state and do the rotations
  183.     glMatrixMode (gl_ModelView);
  184.     // Draw the string
  185.     glListBase (1000);
  186.     glPushMatrix;
  187.     glRotatef (6.0, 1.0, 0.0, 0.0);
  188.     glRotatef (350.0, 0.0, 1.0, 0.0);
  189.     glCallLists (Length (TheText), gl_Unsigned_Byte, PChar (TheText));
  190.     glPopMatrix;
  191.     // Flush drawing commands
  192.     glFlush;
  193. end;
  194.  
  195. procedure TForm1.WMQueryNewPalette (var Message: TWMQueryNewPalette);
  196. begin
  197.     Inherited;
  198.     if hPal <> 0 then begin
  199.         // Selects the palette into the current device context
  200.     SelectPalette (dc, hPal, False);
  201.     // Map entries from current palette to system palette
  202.     RealizePalette (dc);
  203.     // Repaint, forces remap of palette in current window
  204.     InvalidateRect (Handle, Nil, False);
  205.     end;
  206. end;
  207.  
  208. procedure TForm1.WMPaletteChanged (var Message: TWMPaletteChanged);
  209. begin
  210.     Inherited;
  211.     // Don't do anything if the palette does not exist, or if
  212.     // this is the window that changed the palette.
  213.     if (hPal <> 0) and (Handle <> Message.PalChg) then begin
  214.         // Select the palette into the device context
  215.         SelectPalette (dc, hPal, False);
  216.         // Map entries to system palette
  217.         RealizePalette (dc);
  218.         // Remap the current colors to the newly realized palette
  219.         UpdateColors (dc);
  220.     end;
  221. end;
  222.  
  223. procedure TForm1.FormPaint(Sender: TObject);
  224. begin
  225.     // The painting function.  This message sent by Windows
  226.     // whenever the screen needs updating.
  227.     RenderScene ('Delphi 3.0');
  228.     SwapBuffers (dc);
  229.     ValidateRect (Handle, Nil);
  230. end;
  231.  
  232. procedure TForm1.FormDestroy(Sender: TObject);
  233. begin
  234.     // Deselect the current rendering context and delete it
  235.     wglMakeCurrent (dc, 0);
  236.     wglDeleteContext (hRC);
  237.     if hPal <> 0 then DeleteObject (hPal);
  238.     ReleaseDC (Handle, dc);
  239. end;
  240.  
  241. // Change viewing volume and viewport.  Called when window is resized
  242.  
  243. procedure ChangeSize (w, h: GLsizei);
  244. const
  245.     nRange: GLFloat = 125.0;
  246. begin
  247.     // Prevent a divide by zero
  248.     if h = 0 then h := 1;
  249.     // Set Viewport to window dimensions
  250.     glViewport (0, 0, w, h);
  251.     // Reset coordinate system
  252.     glMatrixMode (gl_Projection);
  253.     glLoadIdentity;
  254.     // Establish clipping volume (left, right, bottom, top, near, far)
  255.     if w <= h then glOrtho (-nRange, nRange, -nRange*h/w, nRange*h/w, -nRange*2.0, nRange*2.0)
  256.     else glOrtho (-nRange*w/h, nRange*w/h, -nRange, nRange, -nRange*2.0, nRange*2.0);
  257.     // Set up transformation to draw the string.
  258.     glTranslatef (-110.0, 0.0, -5.0);
  259.     glScalef(60.0, 60.0, 60.0);
  260.     glMatrixMode (gl_ModelView);
  261.     glLoadIdentity;
  262. end;
  263.  
  264. procedure TForm1.FormResize (Sender: TObject);
  265. begin
  266.     ChangeSize (ClientWidth, ClientHeight);
  267.     InvalidateRect (Handle, Nil, False);
  268. end;
  269.  
  270. end.
  271.  
  272.  
  273.